home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue39 / system / ShellBrowser.pas
Encoding:
Pascal/Delphi Source File  |  1998-10-09  |  8.1 KB  |  224 lines
  1. unit ShellBrowser;
  2.  
  3. interface
  4.  
  5. uses
  6.     Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
  7.  
  8. type
  9.     TBrowseSelectionChanged = procedure (Sender: TObject; var NewFolder: String; var Accept: Boolean) of Object;
  10.  
  11.     TShellDomain = ( sdDesktop, sdPrograms, sdControlPanel, sdPrinters, sdMyDocuments,
  12.                      sdFavorites, sdStartup, sdRecent, sdSendTo, sdRecycleBin,
  13.                      sdStartMenu, sdDrives, sdNetwork, sdNetHood, sdFonts );
  14.  
  15.     TBrowseOptions = ( FileSystemDirsOnly, DontGoBelowDomain,
  16.                        IncludeStatusText, ReturnSFAncestors,
  17.                        BrowseComputers, BrowsePrinters,
  18.                        BrowseFiles );
  19.  
  20.     TBrowseOptionSet = set of TBrowseOptions;
  21.  
  22.     TShellBrowser = class(TComponent)
  23.     private
  24.         { Private declarations }
  25.         fLabelTitle: String;
  26.         fFolderPath: String;
  27.         fWindowTitle: String;
  28.         fImageIndex: Integer;
  29.         fStartDir: String;
  30.         fReadOnlyStrProp: String;
  31.         fReadOnlyIntProp: Integer;
  32.         fDomain: TShellDomain;
  33.         fCentred: Boolean;
  34.         fOptions: TBrowseOptionSet;
  35.         fSelectionChanged: TBrowseSelectionChanged;
  36.         function DomainToIDL: Pointer;
  37.         function GetFlags: UINT;
  38.         procedure UpdateStatusText (Wnd: hWnd; const Selection: String);
  39.     protected
  40.         { Protected declarations }
  41.     public
  42.         { Public declarations }
  43.         constructor Create (AOwner: TComponent); override;
  44.         function Execute: Boolean;
  45.     published
  46.         { Published declarations }
  47.         property LabelTitle: String read fLabelTitle write fLabelTitle;
  48.         property Centred: Boolean read fCentred write fCentred default True;
  49.         property FolderPath: String read fFolderPath write fReadOnlyStrProp;
  50.         property WindowTitle: String read fWindowTitle write fWindowTitle;
  51.         property StartDirectory: String read fStartDir write fStartDir;
  52.         property ImageIndex: Integer read fImageIndex write fReadOnlyIntProp;
  53.         property Domain: TShellDomain read fDomain write fDomain default sdDesktop;
  54.         property Options: TBrowseOptionSet read fOptions write fOptions default [FileSystemDirsOnly];
  55.         property OnSelectionChanged: TBrowseSelectionChanged read fSelectionChanged write fSelectionChanged;
  56.     end;
  57.  
  58. procedure Register;
  59.  
  60. implementation
  61.  
  62. uses FileCtrl, ShlObj, ActiveX; { ActiveX needed for IMalloc...sigh.... }
  63.  
  64. procedure CentreWindow (Wnd: HWnd);
  65. var
  66.     Rect: TRect;
  67. begin
  68.     GetWindowRect (Wnd, Rect);
  69.     SetWindowPos (Wnd, 0,
  70.         (Screen.Width - Rect.Right + Rect.Left) div 2,
  71.         (Screen.Height - Rect.Bottom + Rect.Top) div 2,
  72.         0, 0, swp_NoActivate or swp_NoSize or swp_NoZOrder);
  73. end;
  74.  
  75. procedure TShellBrowser.UpdateStatusText (Wnd: hWnd; const Selection: String);
  76. var
  77.     R: TRect;
  78.     S: String;
  79.     StatusWnd: hWnd;
  80. begin
  81.     // Have we got a status label?
  82.     if IncludeStatusText in fOptions then begin
  83.         // WARNING: This requires carnal knowledge of SHELL32.DLL !
  84.         // If Microsoft change the ID of the status label, the code
  85.         // simply won't be able to trim the text to fit.
  86.         S := Selection;
  87.         StatusWnd := GetDlgItem (Wnd, $3743);
  88.         if (StatusWnd <> 0) and IsWindowVisible (StatusWnd) then begin
  89.             // We've got a status window.  Should we trim the text?
  90.             GetWindowRect (StatusWnd, R);
  91.             S := MinimizeName (S, Application.MainForm.Canvas, R.Right - R.Left);
  92.         end;
  93.  
  94.         SendMessage (Wnd, bffm_SetStatusText, 0, Integer (PChar (S)));
  95.     end;
  96. end;
  97.  
  98. function BrowserCallbackProc (Wnd: hWnd; uMsg: UINT; lParam, lpData: LPARAM): Integer; stdcall;
  99. var
  100.     Accept: Boolean;
  101.     Selection: String;
  102.     Buff: array [0..255] of Char;
  103.     Self: TShellBrowser absolute lpData;
  104. begin
  105.     with Self do case uMsg of
  106.         bffm_Initialized:
  107.  
  108.         // This is the initialization call from the browse dialog.
  109.         begin
  110.             // Centre the dialog on screen if fCentred is True.
  111.             if fCentred then CentreWindow (Wnd);
  112.             // Set a custom dialog title if desired.
  113.             if fWindowTitle <> '' then SetWindowText (Wnd, PChar (fWindowTitle));
  114.             // Set an initial directory selection if desired
  115.             if fStartDir <> '' then
  116.                 SendMessage (Wnd, bffm_SetSelection, Ord(True), Integer (PChar (fStartDir)));
  117.         end;
  118.  
  119.         bffm_SelChanged:
  120.  
  121.         // This message is received whenever the folder changes
  122.         // in the browser dialog.  lParam is a pidl to the newly
  123.         // selected folder.
  124.         begin
  125.             Accept := True;
  126.  
  127.             // Retrieve the current selection
  128.             SHGetPathFromIDList (PItemIDList (lParam), Buff);
  129.             Selection := StrPas (Buff);
  130.  
  131.             // Notify application of selection change?
  132.             if Assigned (fSelectionChanged) then
  133.                 fSelectionChanged (Self, Selection, Accept);
  134.  
  135.             // Update status text
  136.             UpdateStatusText (Wnd, Selection);
  137.  
  138.             // Enable/disable OK button as requested
  139.             SendMessage (Wnd, bffm_EnableOK, 0, Ord (Accept));
  140.         end;
  141.     end;
  142.  
  143.     Result := 0;
  144. end;
  145.  
  146. constructor TShellBrowser.Create (AOwner: TComponent);
  147. begin
  148.     Inherited Create (AOwner);
  149.     fCentred := True;
  150.     fOptions := [FileSystemDirsOnly];
  151. end;
  152.  
  153. function TShellBrowser.DomainToIDL: Pointer;
  154. var
  155.     FolderNum: Integer;
  156. begin
  157.     case fDomain of
  158.         sdPrograms:         FolderNum := csidl_Programs;
  159.         sdControlPanel:     FolderNum := csidl_Controls;
  160.         sdPrinters:         FolderNum := csidl_Printers;
  161.         sdMyDocuments:      FolderNum := csidl_Personal;
  162.         sdFavorites:        FolderNum := csidl_Favorites;
  163.         sdStartup:          FolderNum := csidl_Startup;
  164.         sdRecent:           FolderNum := csidl_Recent;
  165.         sdSendTo:           FolderNum := csidl_SendTo;
  166.         sdRecycleBin:       FolderNum := csidl_BitBucket;
  167.         sdStartMenu:        FolderNum := csidl_StartMenu;
  168.         sdDrives:           FolderNum := csidl_Drives;
  169.         sdNetwork:          FolderNum := csidl_Network;
  170.         sdNetHood:          FolderNum := csidl_NetHood;
  171.         sdFonts:            FolderNum := csidl_Fonts;
  172.         else                FolderNum := 0;
  173.     end;
  174.  
  175.     if FolderNum = 0 then Result := Nil else
  176.         SHGetSpecialFolderLocation (Application.Handle, FolderNum, PItemIDList (Result));
  177. end;
  178.  
  179. function TShellBrowser.GetFlags: UINT;
  180. begin
  181.     Result := 0;
  182.     if FileSystemDirsOnly in fOptions then Result := Result or bif_ReturnOnlyFSDirs;
  183.     if DontGoBelowDomain in fOptions then Result := Result or bif_DontGoBelowDomain;
  184.     if IncludeStatusText in fOptions then Result := Result or bif_StatusText;
  185.     if ReturnSFAncestors in fOptions then Result := Result or bif_ReturnFSAncestors;
  186.     if BrowseComputers in fOptions then Result := Result or bif_BrowseForComputer;
  187.     if BrowsePrinters in fOptions then Result := Result or bif_BrowseForPrinter;
  188.     if BrowseFiles in fOptions then Result := Result or bif_BrowseIncludeFiles;
  189. end;
  190.  
  191. function TShellBrowser.Execute: Boolean;
  192. var
  193.     pidl: PItemIDList;
  194.     ShellMalloc: IMalloc;
  195.     BrowseInfo: TBrowseInfo;
  196.     Buff: array [0..255] of Char;
  197. begin
  198.     Result := False;
  199.     if (ShGetMalloc (ShellMalloc) = S_OK) and (ShellMalloc <> Nil) then begin
  200.         BrowseInfo.hwndOwner := Application.Handle;
  201.         BrowseInfo.pidlRoot := DomainToIDL;
  202.         BrowseInfo.pszDisplayName := Nil;
  203.         BrowseInfo.lpszTitle := PChar (fLabelTitle);
  204.         BrowseInfo.ulFlags := GetFlags;
  205.         BrowseInfo.lpfn := BrowserCallbackProc;
  206.         BrowseInfo.lParam := Integer (Self);
  207.  
  208.         pidl := SHBrowseForFolder (BrowseInfo);
  209.         if pidl = Nil then fFolderPath := '' else begin
  210.             Result := SHGetPathFromIDList (pidl, Buff);
  211.             fFolderPath := StrPas (Buff);
  212.             fImageIndex := BrowseInfo.iImage;
  213.             ShellMalloc.Free (pidl);
  214.         end;
  215.     end;
  216. end;
  217.  
  218. procedure Register;
  219. begin
  220.     RegisterComponents ('The X Factor', [TShellBrowser]);
  221. end;
  222.  
  223. end.
  224.